home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1998 November / Freeware November 1998.img / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nnmbox.el.z / nnmbox.el
Lisp/Scheme  |  1998-10-27  |  17KB  |  534 lines
  1. ;;; nnmbox.el --- mail mbox access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; For an overview of what the interface functions do, please see the
  28. ;; Gnus sources.  
  29.  
  30. ;;; Code:
  31.  
  32. (require 'nnheader)
  33. (require 'message)
  34. (require 'nnmail)
  35. (require 'nnoo)
  36. (eval-when-compile (require 'cl))
  37.  
  38. (nnoo-declare nnmbox)
  39.  
  40. (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
  41.   "The name of the mail box file in the user's home directory.")
  42.  
  43. (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
  44.   "The name of the active file for the mail box.")
  45.  
  46. (defvoo nnmbox-get-new-mail t
  47.   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
  48.  
  49. (defvoo nnmbox-prepare-save-mail-hook nil
  50.   "Hook run narrowed to an article before saving.")
  51.  
  52.  
  53.  
  54. (defconst nnmbox-version "nnmbox 1.0"
  55.   "nnmbox version.")
  56.  
  57. (defvoo nnmbox-current-group nil
  58.   "Current nnmbox news group directory.")
  59.  
  60. (defconst nnmbox-mbox-buffer nil)
  61.  
  62. (defvoo nnmbox-status-string "")
  63.  
  64. (defvoo nnmbox-group-alist nil)
  65. (defvoo nnmbox-active-timestamp nil)
  66.  
  67.  
  68.  
  69. ;;; Interface functions
  70.  
  71. (nnoo-define-basics nnmbox)
  72.  
  73. (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
  74.   (save-excursion
  75.     (set-buffer nntp-server-buffer)
  76.     (erase-buffer)
  77.     (let ((number (length sequence))
  78.       (count 0)
  79.       article art-string start stop)
  80.       (nnmbox-possibly-change-newsgroup newsgroup server)
  81.       (while sequence
  82.     (setq article (car sequence))
  83.     (setq art-string (nnmbox-article-string article))
  84.     (set-buffer nnmbox-mbox-buffer)
  85.     (if (or (search-forward art-string nil t)
  86.         (progn (goto-char (point-min))
  87.                (search-forward art-string nil t)))
  88.         (progn
  89.           (setq start 
  90.             (save-excursion
  91.               (re-search-backward 
  92.                (concat "^" message-unix-mail-delimiter) nil t)
  93.               (point)))
  94.           (search-forward "\n\n" nil t)
  95.           (setq stop (1- (point)))
  96.           (set-buffer nntp-server-buffer)
  97.           (insert (format "221 %d Article retrieved.\n" article))
  98.           (insert-buffer-substring nnmbox-mbox-buffer start stop)
  99.           (goto-char (point-max))
  100.           (insert ".\n")))
  101.     (setq sequence (cdr sequence))
  102.     (setq count (1+ count))
  103.     (and (numberp nnmail-large-newsgroup)
  104.          (> number nnmail-large-newsgroup)
  105.          (zerop (% count 20))
  106.          (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
  107.                    (/ (* count 100) number))))
  108.  
  109.       (and (numberp nnmail-large-newsgroup)
  110.        (> number nnmail-large-newsgroup)
  111.        (nnheader-message 5 "nnmbox: Receiving headers...done"))
  112.  
  113.       (set-buffer nntp-server-buffer)
  114.       (nnheader-fold-continuation-lines)
  115.       'headers)))
  116.  
  117. (deffoo nnmbox-open-server (server &optional defs)
  118.   (nnoo-change-server 'nnmbox server defs)
  119.   (cond 
  120.    ((not (file-exists-p nnmbox-mbox-file))
  121.     (nnmbox-close-server)
  122.     (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
  123.    ((file-directory-p nnmbox-mbox-file)
  124.     (nnmbox-close-server)
  125.     (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
  126.    (t
  127.     (nnheader-report 'nnmbox "Opened server %s using mbox %s" server
  128.              nnmbox-mbox-file)
  129.     t)))
  130.  
  131. (deffoo nnmbox-close-server (&optional server)
  132.   (when (and nnmbox-mbox-buffer
  133.          (buffer-name nnmbox-mbox-buffer))
  134.     (kill-buffer nnmbox-mbox-buffer))
  135.   (nnoo-close-server 'nnmbox server)
  136.   t)
  137.  
  138. (deffoo nnmbox-server-opened (&optional server)
  139.   (and (nnoo-current-server-p 'nnmbox server)
  140.        nnmbox-mbox-buffer
  141.        (buffer-name nnmbox-mbox-buffer)
  142.        nntp-server-buffer
  143.        (buffer-name nntp-server-buffer)))
  144.  
  145. (deffoo nnmbox-request-article (article &optional newsgroup server buffer)
  146.   (nnmbox-possibly-change-newsgroup newsgroup server)
  147.   (save-excursion
  148.     (set-buffer nnmbox-mbox-buffer)
  149.     (goto-char (point-min))
  150.     (if (search-forward (nnmbox-article-string article) nil t)
  151.     (let (start stop)
  152.       (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
  153.       (setq start (point))
  154.       (forward-line 1)
  155.       (or (and (re-search-forward 
  156.             (concat "^" message-unix-mail-delimiter) nil t)
  157.            (forward-line -1))
  158.           (goto-char (point-max)))
  159.       (setq stop (point))
  160.       (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
  161.         (set-buffer nntp-server-buffer)
  162.         (erase-buffer)
  163.         (insert-buffer-substring nnmbox-mbox-buffer start stop)
  164.         (goto-char (point-min))
  165.         (while (looking-at "From ")
  166.           (delete-char 5)
  167.           (insert "X-From-Line: ")
  168.           (forward-line 1))
  169.         (if (numberp article) 
  170.         (cons nnmbox-current-group article)
  171.           (nnmbox-article-group-number)))))))
  172.  
  173. (deffoo nnmbox-request-group (group &optional server dont-check)
  174.   (let ((active (cadr (assoc group nnmbox-group-alist))))
  175.     (cond 
  176.      ((or (null active)
  177.       (null (nnmbox-possibly-change-newsgroup group server)))
  178.       (nnheader-report 'nnmbox "No such group: %s" group))
  179.      (dont-check
  180.       (nnheader-report 'nnmbox "Selected group %s" group)
  181.       (nnheader-insert ""))
  182.      (t
  183.       (nnheader-report 'nnmbox "Selected group %s" group)
  184.       (nnheader-insert "211 %d %d %d %s\n" 
  185.                (1+ (- (cdr active) (car active)))
  186.                (car active) (cdr active) group)))))
  187.  
  188. (deffoo nnmbox-request-scan (&optional group server)
  189.   (nnmbox-read-mbox)
  190.   (nnmail-get-new-mail 
  191.    'nnmbox 
  192.    (lambda ()
  193.      (save-excursion
  194.        (set-buffer nnmbox-mbox-buffer)
  195.        (save-buffer)))
  196.    nnmbox-mbox-file group
  197.    (lambda ()
  198.      (save-excursion
  199.        (let ((in-buf (current-buffer)))
  200.      (set-buffer nnmbox-mbox-buffer)
  201.      (goto-char (point-max))
  202.      (insert-buffer-substring in-buf)))
  203.      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
  204.  
  205. (deffoo nnmbox-close-group (group &optional server)
  206.   t)
  207.  
  208. (deffoo nnmbox-request-list (&optional server)
  209.   (save-excursion
  210.     (nnmail-find-file nnmbox-active-file)
  211.     (setq nnmbox-group-alist (nnmail-get-active))))
  212.  
  213. (deffoo nnmbox-request-newgroups (date &optional server)
  214.   (nnmbox-request-list server))
  215.  
  216. (deffoo nnmbox-request-list-newsgroups (&optional server)
  217.   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
  218.  
  219. (deffoo nnmbox-request-expire-articles 
  220.   (articles newsgroup &optional server force)
  221.   (nnmbox-possibly-change-newsgroup newsgroup server)
  222.   (let* ((is-old t)
  223.      rest)
  224.     (nnmail-activate 'nnmbox)
  225.  
  226.     (save-excursion 
  227.       (set-buffer nnmbox-mbox-buffer)
  228.       (while (and articles is-old)
  229.     (goto-char (point-min))
  230.     (if (search-forward (nnmbox-article-string (car articles)) nil t)
  231.         (if (setq is-old
  232.               (nnmail-expired-article-p
  233.                newsgroup
  234.                (buffer-substring 
  235.             (point) (progn (end-of-line) (point))) force))
  236.         (progn
  237.           (nnheader-message 5 "Deleting article %d in %s..."
  238.                     (car articles) newsgroup)
  239.           (nnmbox-delete-mail))
  240.           (setq rest (cons (car articles) rest))))
  241.     (setq articles (cdr articles)))
  242.       (save-buffer)
  243.       ;; Find the lowest active article in this group.
  244.       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
  245.     (goto-char (point-min))
  246.     (while (and (not (search-forward
  247.               (nnmbox-article-string (car active)) nil t))
  248.             (<= (car active) (cdr active)))
  249.       (setcar active (1+ (car active)))
  250.       (goto-char (point-min))))
  251.       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  252.       (nconc rest articles))))
  253.  
  254. (deffoo nnmbox-request-move-article
  255.   (article group server accept-form &optional last)
  256.   (nnmbox-possibly-change-newsgroup group server)
  257.   (let ((buf (get-buffer-create " *nnmbox move*"))
  258.     result)
  259.     (and 
  260.      (nnmbox-request-article article group server)
  261.      (save-excursion
  262.        (set-buffer buf)
  263.        (buffer-disable-undo (current-buffer))
  264.        (erase-buffer)
  265.        (insert-buffer-substring nntp-server-buffer)
  266.        (goto-char (point-min))
  267.        (while (re-search-forward 
  268.            "^X-Gnus-Newsgroup:" 
  269.            (save-excursion (search-forward "\n\n" nil t) (point)) t)
  270.      (delete-region (progn (beginning-of-line) (point))
  271.             (progn (forward-line 1) (point))))
  272.        (setq result (eval accept-form))
  273.        (kill-buffer buf)
  274.        result)
  275.      (save-excursion
  276.        (set-buffer nnmbox-mbox-buffer)
  277.        (goto-char (point-min))
  278.        (if (search-forward (nnmbox-article-string article) nil t)
  279.        (nnmbox-delete-mail))
  280.        (and last (save-buffer))))
  281.     result))
  282.  
  283. (deffoo nnmbox-request-accept-article (group &optional server last)
  284.   (nnmbox-possibly-change-newsgroup group server)
  285.   (nnmail-check-syntax)
  286.   (let ((buf (current-buffer))
  287.     result)
  288.     (goto-char (point-min))
  289.     (if (looking-at "X-From-Line: ")
  290.     (replace-match "From ")
  291.       (insert "From nobody " (current-time-string) "\n"))
  292.     (and 
  293.      (nnmail-activate 'nnmbox)
  294.      (progn
  295.        (set-buffer buf)
  296.        (goto-char (point-min))
  297.        (search-forward "\n\n" nil t)
  298.        (forward-line -1)
  299.        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
  300.      (delete-region (point) (progn (forward-line 1) (point))))
  301.        (setq result (nnmbox-save-mail (and (stringp group) group))))
  302.      (save-excursion
  303.        (set-buffer nnmbox-mbox-buffer)
  304.        (goto-char (point-max))
  305.        (insert-buffer-substring buf)
  306.        (and last (save-buffer))
  307.        result)
  308.      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
  309.     (car result)))
  310.  
  311. (deffoo nnmbox-request-replace-article (article group buffer)
  312.   (nnmbox-possibly-change-newsgroup group)
  313.   (save-excursion
  314.     (set-buffer nnmbox-mbox-buffer)
  315.     (goto-char (point-min))
  316.     (if (not (search-forward (nnmbox-article-string article) nil t))
  317.     nil
  318.       (nnmbox-delete-mail t t)
  319.       (insert-buffer-substring buffer)
  320.       (save-buffer)
  321.       t)))
  322.  
  323. (deffoo nnmbox-request-delete-group (group &optional force server)
  324.   (nnmbox-possibly-change-newsgroup group server)
  325.   ;; Delete all articles in GROUP.
  326.   (if (not force)
  327.       ()                ; Don't delete the articles.
  328.     (save-excursion
  329.       (set-buffer nnmbox-mbox-buffer)
  330.       (goto-char (point-min))
  331.       ;; Delete all articles in this group.
  332.       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
  333.         found)
  334.     (while (search-forward ident nil t)
  335.       (setq found t)
  336.       (nnmbox-delete-mail))
  337.     (and found (save-buffer)))))
  338.   ;; Remove the group from all structures.
  339.   (setq nnmbox-group-alist 
  340.     (delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
  341.     nnmbox-current-group nil)
  342.   ;; Save the active file.
  343.   (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  344.   t)
  345.  
  346. (deffoo nnmbox-request-rename-group (group new-name &optional server)
  347.   (nnmbox-possibly-change-newsgroup group server)
  348.   (save-excursion
  349.     (set-buffer nnmbox-mbox-buffer)
  350.     (goto-char (point-min))
  351.     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
  352.       (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
  353.       found)
  354.       (while (search-forward ident nil t)
  355.     (replace-match new-ident t t)
  356.     (setq found t))
  357.       (and found (save-buffer))))
  358.   (let ((entry (assoc group nnmbox-group-alist)))
  359.     (and entry (setcar entry new-name))
  360.     (setq nnmbox-current-group nil)
  361.     ;; Save the new group alist.
  362.     (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
  363.     t))
  364.  
  365.  
  366. ;;; Internal functions.
  367.  
  368. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
  369. ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
  370. ;; delimiter line.
  371. (defun nnmbox-delete-mail (&optional force leave-delim)
  372.   ;; Delete the current X-Gnus-Newsgroup line.
  373.   (or force
  374.       (delete-region
  375.        (progn (beginning-of-line) (point))
  376.        (progn (forward-line 1) (point))))
  377.   ;; Beginning of the article.
  378.   (save-excursion
  379.     (save-restriction
  380.       (narrow-to-region
  381.        (save-excursion
  382.      (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
  383.      (if leave-delim (progn (forward-line 1) (point))
  384.        (match-beginning 0)))
  385.        (progn
  386.      (forward-line 1)
  387.      (or (and (re-search-forward (concat "^" message-unix-mail-delimiter) 
  388.                      nil t)
  389.           (if (and (not (bobp)) leave-delim)
  390.               (progn (forward-line -2) (point))
  391.             (match-beginning 0)))
  392.          (point-max))))
  393.       (goto-char (point-min))
  394.       ;; Only delete the article if no other groups owns it as well.
  395.       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
  396.       (delete-region (point-min) (point-max))))))
  397.  
  398. (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
  399.   (when (and server 
  400.          (not (nnmbox-server-opened server)))
  401.     (nnmbox-open-server server))
  402.   (if (or (not nnmbox-mbox-buffer)
  403.       (not (buffer-name nnmbox-mbox-buffer)))
  404.       (save-excursion
  405.     (set-buffer (setq nnmbox-mbox-buffer 
  406.               (nnheader-find-file-noselect
  407.                nnmbox-mbox-file nil 'raw)))
  408.     (buffer-disable-undo (current-buffer))))
  409.   (if (not nnmbox-group-alist)
  410.       (nnmail-activate 'nnmbox))
  411.   (if newsgroup
  412.       (if (assoc newsgroup nnmbox-group-alist)
  413.       (setq nnmbox-current-group newsgroup))
  414.     t))
  415.  
  416. (defun nnmbox-article-string (article)
  417.   (if (numberp article)
  418.       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":" 
  419.           (int-to-string article) " ")
  420.     (concat "\nMessage-ID: " article)))
  421.  
  422. (defun nnmbox-article-group-number ()
  423.   (save-excursion
  424.     (goto-char (point-min))
  425.     (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
  426.                 nil t)
  427.      (cons (buffer-substring (match-beginning 1) (match-end 1))
  428.            (string-to-int
  429.         (buffer-substring (match-beginning 2) (match-end 2)))))))
  430.  
  431. (defun nnmbox-save-mail (&optional group)
  432.   "Called narrowed to an article."
  433.   (let* ((nnmail-split-methods 
  434.       (if group (list (list group "")) nnmail-split-methods))
  435.      (group-art (nreverse (nnmail-article-group 'nnmbox-active-number)))
  436.      (delim (concat "^" message-unix-mail-delimiter)))
  437.     (goto-char (point-min))
  438.     ;; This might come from somewhere else.
  439.     (unless (looking-at delim)
  440.       (insert "From nobody " (current-time-string) "\n")
  441.       (goto-char (point-min)))
  442.     ;; Quote all "From " lines in the article.
  443.     (forward-line 1)
  444.     (while (re-search-forward delim nil t)
  445.       (beginning-of-line)
  446.       (insert "> "))
  447.     (nnmail-insert-lines)
  448.     (nnmail-insert-xref group-art)
  449.     (nnmbox-insert-newsgroup-line group-art)
  450.     (run-hooks 'nnmail-prepare-save-mail-hook)
  451.     (run-hooks 'nnmbox-prepare-save-mail-hook)
  452.     group-art))
  453.  
  454. (defun nnmbox-insert-newsgroup-line (group-art)
  455.   (save-excursion
  456.     (goto-char (point-min))
  457.     (if (search-forward "\n\n" nil t)
  458.     (progn
  459.       (forward-char -1)
  460.       (while group-art
  461.         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n" 
  462.                 (caar group-art) (cdar group-art)
  463.                 (current-time-string)))
  464.         (setq group-art (cdr group-art)))))
  465.     t))
  466.  
  467. (defun nnmbox-active-number (group)
  468.   ;; Find the next article number in GROUP.
  469.   (let ((active (cadr (assoc group nnmbox-group-alist))))
  470.     (if active
  471.     (setcdr active (1+ (cdr active)))
  472.       ;; This group is new, so we create a new entry for it.
  473.       ;; This might be a bit naughty... creating groups on the drop of
  474.       ;; a hat, but I don't know...
  475.       (setq nnmbox-group-alist (cons (list group (setq active (cons 1 1)))
  476.                      nnmbox-group-alist)))
  477.     (cdr active)))
  478.  
  479. (defun nnmbox-read-mbox ()
  480.   (nnmail-activate 'nnmbox)
  481.   (if (not (file-exists-p nnmbox-mbox-file))
  482.       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
  483.   (if (and nnmbox-mbox-buffer
  484.        (buffer-name nnmbox-mbox-buffer)
  485.        (save-excursion
  486.          (set-buffer nnmbox-mbox-buffer)
  487.          (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
  488.       ()
  489.     (save-excursion
  490.       (let ((delim (concat "^" message-unix-mail-delimiter))
  491.         (alist nnmbox-group-alist)
  492.         start end number)
  493.     (set-buffer (setq nnmbox-mbox-buffer 
  494.               (nnheader-find-file-noselect
  495.                nnmbox-mbox-file nil 'raw)))
  496.     (buffer-disable-undo (current-buffer))
  497.  
  498.     ;; Go through the group alist and compare against
  499.     ;; the mbox file.
  500.     (while alist
  501.       (goto-char (point-max))
  502.       (when (and (re-search-backward
  503.               (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
  504.                   (caar alist)) nil t)
  505.              (>= (setq number
  506.                    (string-to-number 
  507.                 (buffer-substring
  508.                  (match-beginning 1) (match-end 1))))
  509.              (cdadar alist)))
  510.         (setcdr (cadar alist) (1+ number)))
  511.       (setq alist (cdr alist)))
  512.     
  513.     (goto-char (point-min))
  514.     (while (re-search-forward delim nil t)
  515.       (setq start (match-beginning 0))
  516.       (if (not (search-forward "\nX-Gnus-Newsgroup: " 
  517.                    (save-excursion 
  518.                      (setq end
  519.                        (or
  520.                         (and
  521.                          (re-search-forward delim nil t)
  522.                          (match-beginning 0))
  523.                         (point-max))))
  524.                    t))
  525.           (save-excursion
  526.         (save-restriction
  527.           (narrow-to-region start end)
  528.           (nnmbox-save-mail))))
  529.       (goto-char end))))))
  530.  
  531. (provide 'nnmbox)
  532.  
  533. ;;; nnmbox.el ends here
  534.